{Generate a barcode according to the UPC-A characterset    }
{A string of custom digits (<10) is checked for size       }
{for digit-only and then zero-primed                       }
{the checksum is calculated and the UPC-digit is inserted  }
{the 12-digit string is converted into plain barcode pixels}
{the upc-pixels for start- middle- and endcode are inserted}
{a pixelbuffer containing the complete barcode is returned }
{if the function results 1 (no error)                      }

{Copyrights: Ard Jonker, Amsterdam 1997.                   }

{Remarks, questions and bugs to A.jonker@amc.uva.nl or a_team@dds.nl}

function getdigit(s,this):integer;
var tempstring:string;
begin
  {return the nth character from the left side, in s}
   Delete(s,this+1,length(s)-this);
   Delete(s,1,length(s)-1);
   getdigit:=stringtonum(s);
end;

function checkcode(s):integer;
     {calculate the checkdigit}
 var oddsum,evensum,i,thisdigit:integer;
     {thisdigit:string;}
begin
  oddsum:=0;evensum:=0;
  for i:=1 to length(s) do begin
    {use stripped digits right to left}
    thisdigit:=getdigit(s,length(s)-i+1);
    if i mod 2 = 0 then
      evensum:=evensum+thisdigit
    else
      oddsum:=oddsum+thisdigit;
  end;
  oddsum:=oddsum*3;
  thisdigit:=(10-((oddsum+evensum) mod 10))mod 10;
  checkcode:=thisdigit;
end;

procedure SelectBarcodeWin
var i,available:integer;
begin
  available:=0;
  for i:=1 to npics do begin
    selectPic(i);
    if(windowtitle='Barcode') then available:=1;
  end;
  if not available then begin
    SetNewSize(107,60);
    MakeNewWindow('Barcode');
    MoveWindow(200,200);
  end;
  SelectWindow('barcode');
end

procedure clearbars
var i:integer;
begin
  SelectBarcodeWin;
  SelectAll;clear;
  for i:=0 to (3+6*7+5+6*7+3) do
    LineBuffer[i]:=0;
  end;
end;

procedure startbars
begin
  LineBuffer[1]:=255;  LineBuffer[3]:=255;
end;
procedure middlebars
begin
  LineBuffer[47]:=255; LineBuffer[49]:=255;
end;
procedure endbars
begin
  LineBuffer[93]:=255; LineBuffer[95]:=255;
end;

procedure BarsToImage(extra)
var available,i:integer;
begin
  For i:=0 to 50+extra do
    PutRow(5,i,96);
end;

function lbitpat(n):string;
begin
  if n=0 then lbitpat:='0001101';
  if n=1 then lbitpat:='0011001';
  if n=2 then lbitpat:='0010011';
  if n=3 then lbitpat:='0111101';
  if n=4 then lbitpat:='0100011';
  if n=5 then lbitpat:='0110001';
  if n=6 then lbitpat:='0101111';
  if n=7 then lbitpat:='0111011';
  if n=8 then lbitpat:='0110111';
  if n=9 then lbitpat:='0001011';
end;

function rbitpat(n):string;
var i:integer;tempstr,outstr:string;
begin
 tempstr:=lbitpat(n);outstr:='';
 for i:=1 to 7 do 
   outstr:=concat(outstr,(1-getdigit(tempstr,i)):1);
 rbitpat:=outstr;
end;

procedure leftdigits(s);
var thisdigit,i:integer;
    coding:string;
begin
  for thisdigit:=1 to 6 do begin
    coding:=lbitpat(getdigit(s,thisdigit));
    for i:=1 to 7 do begin
       if getdigit(coding,i) then begin
          LineBuffer[3+i+7*(thisdigit-1)]:=255;
       end;
    end;
  end;
end;

procedure rightdigits(s);
var thisdigit,i:integer;
    coding:string;
begin
  for thisdigit:=7 to 12 do begin
    coding:=rbitpat(getdigit(s,thisdigit));
    for i:=1 to 7 do begin
       if getdigit(coding,i) then begin
          LineBuffer[8+i+7*(thisdigit-1)]:=255;
       end;
    end;
  end;
end;

procedure TextToImage(s)
  var lstr,rstr:string;
begin
  SelectBarcodeWin;
  lstr:=s;
  Delete(lstr,7,6);
  MoveTo(13,55);
  Write(lstr);
  rstr:=s;
  Delete(rstr,1,6);
  MoveTo(60,55);Write(rstr);
end;

function UPCA(s,UPCcode):integer;
var zeroes:string;
    result:integer;
begin
  if length(s)>10 then
    result:=-1*(length(s))
  else begin
    zeroes:='0000000000';
    Delete(zeroes,1,length(s));{perpare priming string of zeros}
    s:=concat(UPCcode:1,zeroes,s);
    s:=concat(s,checkcode(s):1);
    {now s contains the entire UPC-A number of 12 digits, containing}
    {1 UPC system digit,10 data digits and 1 checkdigit}
    clearbars;startbars;middlebars;endbars;
    BarsToImage(5);
    leftdigits(s);rightdigits(s);
    BarsToImage(0);
    TextToImage(s);
    result:=1;
  end;
  UPCA:=result;
end;

macro 'test/1';
var mystring:string;
    dummy,i,j,number:integer;
begin
  SetNewSize(350,350);
  MakeNewWindow('wholebars');
  for i:= 0 to 4 do begin
    for j:=0 to 2 do begin
      number:=199700000 + i*3 +j;
      mystring:=concat(number:10);
      ShowMessage('<',mystring,'>');
      if not(UPCA(mystring,0)) then exit;
      SelectBarcodeWindow;
      SelectAll;copy;
      SelectWindow('wholebars');
      MakeRoi(j*110,i*70,107,60);Paste;KillROI;
    end;
  end;
end;